home *** CD-ROM | disk | FTP | other *** search
/ IRIS Performer 2.2 Friends Demo / SGI IRIS Performer 2.2 Friends Demo.iso / friends / openworlds / tix / Select.tcl < prev    next >
Text File  |  1997-11-22  |  7KB  |  289 lines
  1. # Select.tcl --
  2. #
  3. #    Implement the tixSelect widget.
  4. #
  5. # requirement of -valiable
  6. # 1: Always updated before -command is called
  7. #
  8. #
  9.  
  10. tixWidgetClass tixSelect {
  11.     -superclass tixLabelWidget
  12.     -classname  TixSelect
  13.     -method {
  14.     add button invoke
  15.     }
  16.     -flag {
  17.     -allowzero -buttontype -command -disablecallback
  18.     -orientation -orient
  19.     -padx -pady -radio -selectedbg -state -validatecmd
  20.     -value -variable
  21.     }
  22.     -forcecall {
  23.     -variable
  24.     }
  25.     -static {
  26.     -allowzero -orientation -padx -pady -radio
  27.     }
  28.     -configspec {
  29.     {-allowzero allowZero AllowZero false}
  30.     {-buttontype buttonType ButtonType button}
  31.     {-command command Command {}}
  32.     {-disablecallback disableCallback DisableCallback false}
  33.     {-orientation orientation Orientation horizontal}
  34.     {-padx padx Pad 0}
  35.     {-pady pady Pad 0}
  36.     {-radio radio Radio true}
  37.     {-selectedbg selectedBg SelectedBg gray}
  38.     {-state state State normal}
  39.     {-validatecmd validateCmd ValidateCmd {}}
  40.     {-value value Value {}}
  41.     {-variable variable Variable {}}
  42.     }
  43.     -alias {
  44.     {-orient -orientation}
  45.     }
  46.     -default {
  47.     {*frame.borderWidth            1}
  48.     {*frame.relief                sunken}
  49.     {*Button.borderWidth            2}
  50.     {*Button.highlightThickness        0}
  51.     }
  52. }
  53.  
  54. proc tixSelect::InitWidgetRec {w} {
  55.     upvar #0 $w data
  56.  
  57.     tixChainMethod $w InitWidgetRec
  58.     set data(items)    {}
  59.     set data(buttonbg) {}
  60.     set data(varInited)      0
  61.  
  62.     if [catch {tixGetBoolean $data(-radio)}] {
  63.     puts "tixSelect: non-boolean value for -radio \"$data(-radio)\""
  64.     set data(-radio) true
  65.     } 
  66.     if [catch {tixGetBoolean $data(-allowzero)}] {
  67.     puts "tixSelect: non-boolean value for -allowzero \"$data(-radio)\""
  68.     set data(-allowzero) false
  69.     } 
  70.  
  71. }
  72.  
  73. #----------------------------------------------------------------------
  74. #                           CONFIG OPTIONS
  75. #----------------------------------------------------------------------
  76. proc tixSelect::config-state {w arg} {
  77.     upvar #0 $w data
  78.  
  79.     if {$arg == "disabled"} {
  80.     foreach item $data(items) {
  81.         $data(w:$item) config -state disabled -relief raised \
  82.         -bg $data(buttonbg)
  83.     }
  84.     } else {
  85.     foreach item $data(items) {
  86.         if {[lsearch $data(-value) $item] != -1} {
  87.         # This button is selected
  88.         #
  89.         $data(w:$item) config -relief sunken -bg $data(-selectedbg) \
  90.             -state normal
  91.         } else {
  92.         $data(w:$item) config -relief raised -bg $data(buttonbg) \
  93.             -command "$w invoke $item" -state normal
  94.         }
  95.     }
  96.     }
  97. }
  98.  
  99. proc tixSelect::config-variable {w arg} {
  100.     upvar #0 $w data
  101.  
  102.     set oldValue $data(-value)
  103.  
  104.     if [tixVariable:ConfigVariable $w $arg] {
  105.     # The value of data(-value) is changed if tixVariable:ConfigVariable 
  106.     # returns true
  107.     set newValue $data(-value)
  108.     set data(-value) $oldValue
  109.     tixSelect::config-value $w $newValue
  110.     }
  111.     catch {
  112.     unset data(varInited)
  113.     }
  114.     set data(-variable) $arg
  115. }
  116.  
  117. proc tixSelect::config-value {w value} {
  118.     upvar #0 $w data
  119.  
  120.     # sanity checking
  121.     #
  122.     foreach item $value {
  123.     if {[lsearch $data(items) $item] == "-1"} {
  124.         error "subwidget \"$item\" does not exist"
  125.     }
  126.     }
  127.  
  128.     tixSelect::SetValue $w $value
  129. }
  130.  
  131. #----------------------------------------------------------------------
  132. #                     WIDGET COMMANDS
  133. #----------------------------------------------------------------------
  134. proc tixSelect::add {w name args} {
  135.     upvar #0 $w data
  136.  
  137.     set data(w:$name) [eval $data(-buttontype) $data(w:frame).$name -command \
  138.      [list "$w invoke $name"] -takefocus 0 $args]
  139.  
  140.     if {$data(-orientation) == "horizontal"} {
  141.     pack $data(w:$name) -side left -expand yes -fill y\
  142.         -padx $data(-padx) -pady $data(-pady)
  143.     } else {
  144.     pack $data(w:$name) -side top -expand yes  -fill x\
  145.         -padx $data(-padx) -pady $data(-pady)
  146.     }
  147.  
  148.     if {$data(-state) == "disabled"} {
  149.     $data(w:name) config -relief raised -state disabled
  150.     }
  151.  
  152.     # find out the background of the buttons
  153.     #
  154.     if {$data(buttonbg) == {}} {
  155.     set data(buttonbg) [lindex [$data(w:$name) config -background] 4]
  156.     
  157.     }
  158.  
  159.     lappend data(items) $name
  160. }
  161.  
  162. # Obsolete command
  163. #
  164. proc tixSelect::button {w name args} {
  165.     upvar #0 $w data
  166.  
  167.     if {$args != {}} {
  168.     return [eval $data(w:$name) $args]
  169.     } else {
  170.     return $w.$name
  171.     }
  172. }
  173.  
  174. # This is called when a button is invoked
  175. #
  176. proc tixSelect::invoke {w button} {
  177.     upvar #0 $w data
  178.  
  179.     if {$data(-state) != "normal"} {
  180.     return
  181.     }
  182.  
  183.     set newValue $data(-value)
  184.  
  185.     if {[lsearch $data(-value) $button] != -1} {
  186.     # This button was selected
  187.     #
  188.         if {[llength $data(-value)] > 1 || [tixGetBoolean $data(-allowzero)]} {
  189.  
  190.         # Take the button from the selected list
  191.         #
  192.         set newValue {}
  193.         foreach item $data(-value) {
  194.         if {$item != $button} {
  195.             lappend newValue $item
  196.         }
  197.         }
  198.     }
  199.     } else {
  200.     # This button was not selected
  201.     #
  202.     if [tixGetBoolean $data(-radio)] {
  203.         # The button become the sole item in the list
  204.         #
  205.         set newValue [list $button]
  206.     } else {
  207.         # Add this button into the list
  208.         #
  209.         lappend newValue $button
  210.     }
  211.     }
  212.  
  213.     if {$newValue != $data(-value)} {
  214.     tixSelect::SetValue $w $newValue
  215.     }
  216. }
  217.  
  218. #----------------------------------------------------------------------
  219. #                Private functions
  220. #----------------------------------------------------------------------
  221. proc tixSelect::SetValue {w newValue {noUpdate 0}} {
  222.     upvar #0 $w data
  223.  
  224.     set oldValue $data(-value)
  225.  
  226.     if {$data(-validatecmd) != {}} {
  227.     set data(-value) [eval $data(-validatecmd) [list $newValue]]
  228.     } else {
  229.     if {[tixGetBoolean $data(-radio)] && [llength $newValue] > 1} {
  230.         error "cannot choose more than one items in a radio box"
  231.     }
  232.  
  233.     if {![tixGetBoolean $data(-allowzero)] && [llength $newValue] == 0} {
  234.         error "empty selection not allowed"
  235.     }
  236.  
  237.     set data(-value) $newValue
  238.     }
  239.  
  240.     if {! $noUpdate} {
  241.     tixVariable:UpdateVariable $w
  242.     }
  243.  
  244.     # Reset all to be unselected
  245.     #
  246.     foreach item $data(items) {
  247.     if {[lsearch $data(-value) $item] == -1} {
  248.         # Is unselected
  249.         #
  250.         if {[lsearch $oldValue $item] != -1} {
  251.         # was selected
  252.         # -> popup the button, call command
  253.         #
  254.         $data(w:$item) config -relief raised -bg $data(buttonbg)
  255.         tixSelect::CallCommand $w $item 0
  256.         }
  257.     } else {
  258.         # Is selected
  259.         #
  260.         if {[lsearch $oldValue $item] == -1} {
  261.         # was unselected
  262.         # -> push down the button, call command
  263.         #
  264.         $data(w:$item) config -relief sunken -bg $data(-selectedbg)
  265.         tixSelect::CallCommand $w  $item 1
  266.         }
  267.     }
  268.     }
  269. }
  270.  
  271. proc tixSelect::CallCommand {w name value} {
  272.     upvar #0 $w data
  273.  
  274.     if {![tixGetBoolean $data(-disablecallback)] && $data(-command) != {}} {
  275.     if {![info exists data(varInited)]} {
  276.         eval $data(-command) $name $value
  277.     }
  278.     }
  279. }
  280.  
  281. proc tixSelect::Destructor {w} {
  282.  
  283.     tixVariable:DeleteVariable $w
  284.  
  285.     # Chain this to the superclass
  286.     #
  287.     tixChainMethod $w Destructor
  288. }
  289.